home *** CD-ROM | disk | FTP | other *** search
/ Fifty: Elektronik / FIFTY Elektronik (PS_Computer_Vertrieb).iso / ps8 / fty1017 / gepackt.exe / DISK2 / PLOTSRC.EXE / PLSTEUER.INC < prev    next >
Encoding:
Text File  |  1993-11-10  |  25.9 KB  |  973 lines
  1. Const PendownCount:Word=0;
  2.  
  3. Procedure Tausche(Var X,Y :Integer);
  4. Var T :Integer;
  5. begin T:=X; X:=Y; Y:=T; end;
  6.  
  7.  
  8. Procedure SetPen(Color :GrColor);
  9. Var Pen :GrColor;
  10. begin
  11.   Pen :=PenLookUp[Color];
  12.   If (Color > 0) and (Color<= Succ(MaxLayer)) and (Pen<>PlOldPen) Then
  13.   Begin
  14.     PlOldPen:=Pen;
  15.     With Setupinfo.PinstInfo do
  16.       If SelpenCom<>'' then
  17.     If  NoError Then
  18.         begin
  19.         {$I-}
  20.           Write(PrOutFile,SelpenCom,Pen,EndSym);
  21.           If AufDatei Then  NoError:=IOresult=0;
  22.         {$I+}
  23.         end;
  24.   End;
  25. end;
  26.  
  27.  
  28. Procedure Pencolor(Color :GrColor); { = Pen-Nummer }
  29. Begin
  30.   GrDrawColor:=Color;
  31. End;
  32.  
  33. Procedure CheckPen(Var DrawMode:Str15);
  34. {für Emulation getsrichelter Linien}
  35. begin
  36.   With Setupinfo.PinstInfo do
  37.     If Grdotted=dashed then
  38.      begin
  39.        If S_Count>=0.599 then Drawmode:=MoveCom
  40.        else DrawMode:=DrawCom;
  41.      end
  42.     else
  43.      begin { dotted}
  44.       If S_Count>=0.847 then Drawmode:=MoveCom
  45.        else If S_Count>0.748 then DrawMode:=DrawCom
  46.        else If S_Count>=0.599 then Drawmode:=MoveCom
  47.          else DrawMode:=DrawCom;
  48.      end;
  49. end;
  50.  
  51. Procedure CheckCount; {für Emulation getsrichelter Linien}
  52. begin
  53.   If Grdotted=dashed then
  54.   begin
  55.     If S_Count>=0.998 then
  56.      begin
  57.       S_count:=0;
  58.       S_count_rest:=0.6;
  59.      end
  60.      else
  61.       If S_Count>=0.599 then
  62.         S_count_rest:=0.4
  63.           else S_count_rest:=0.6;
  64.    end
  65.   else {dotted0}
  66.    begin
  67.     If S_Count>=0.996 then
  68.      begin
  69.       S_count:=0;
  70.       S_count_rest:=0.6;
  71.      end
  72.      else If S_Count>=0.847 then S_count_rest:=0.15
  73.      else If S_Count>=0.748 then S_count_rest:=0.1
  74.      else If S_Count>=0.599 then S_count_rest:=0.15
  75.        else S_count_rest:=0.6;
  76.    end;
  77. end;
  78.  
  79.  
  80. Procedure Linetype(Typ : GrLineType);
  81. Begin
  82.   If GrDotted <> Typ Then
  83.    If  NoError Then
  84.     With Setupinfo.PinstInfo do
  85.     Begin
  86.       If Emul_LT then
  87.       begin
  88.        If Typ<>LastLineType then
  89.        begin
  90.          Case Typ of
  91.            dotted: begin
  92.                       LastLineType:=Typ;
  93.                       S_count:=0;
  94.                       S_count_rest:=0.6;
  95.                       Linienteilung:=PlotKoord(LScaledotted);
  96.                     end;
  97.             dashed: begin
  98.                       LastLineType:=Typ;
  99.                       S_count:=0;
  100.                       S_count_rest:=0.6;
  101.                       Linienteilung:=PlotKoord(LScaleDashed);
  102.                      end;
  103.          end; {Case}
  104.         end; {If Typ<>}
  105.       end
  106.       else
  107.       begin
  108.         {$I-}
  109.         With SetUpInfo.PinstInfo Do
  110.         If HpGl Then
  111.           Case Typ OF
  112.             full   : Write(PrOutFile,LTfullCom,EndSym);
  113.             dashed : begin
  114.                         RealStr(Lscaledashed*LineScaleFac,6,Outstring);
  115.                         Write(PrOutFile,LTdashCom,SepSym,Outstring,EndSym);
  116.                      end;
  117.             dotted :  begin
  118.                           RealStr(Lscaledotted*LineScaleFac,6,Outstring);
  119.                           Write(PrOutFile,LTdotCom,SepSym,Outstring,EndSym);
  120.                         end;
  121.           End
  122.         else
  123.           Case Typ OF
  124.             full   : Write(PrOutFile,LTFullCom,EndSym);
  125.             dashed : Write(PrOutFile,LTdashCom,Endsym,
  126.                            LSCom,RealtoInt(Lscaledashed*LineScaleFac),EndSym);
  127.             dotted : Write(PrOutFile,LTdotCom,EndSym,
  128.                            LsCom,RealtoInt(Lscaledotted*LineScaleFac),EndSym);
  129.           End;
  130.         If AufDatei Then  NoError:=IOresult=0;
  131.         {$I+}
  132.       end;
  133.       GrDotted:=Typ;
  134.     end;
  135. End;
  136.  
  137. Procedure FormReals(X:Real;Var S:Str10);
  138. Var I:Integer;
  139.   begin
  140.     Str(X:7:0,S);
  141.     I:=0;
  142.     Repeat
  143.        I:=Succ(I);
  144.     Until S[I]<>' ';
  145.     Delete(S,1,I-1);
  146.   end;
  147.  
  148. Procedure DrehenSpiegeln(Var X,Y :Real);
  149. Var Xtemp :Real;
  150. begin
  151.    If Portrait Then
  152.    begin
  153.      Xtemp:=X; X:=GrWindowX2-Y; Y:=Xtemp;
  154.    end;
  155.    If Spiegeln then
  156.       Y:=GrWindowY1+(GrWindowY2-Y);
  157. end;
  158.  
  159. Procedure RetourAbbild(Var X,Y :Real);
  160. Var Ytemp :Real;
  161. begin
  162.    If Spiegeln then Y:=GrWindowY1+(GrWindowY2-Y);
  163.    If Portrait Then
  164.    begin
  165.      Ytemp:=Y;
  166.      Y:=GrWindowX2-X;
  167.      X:=Ytemp;
  168.    end;
  169. end;
  170.  
  171. Procedure Moveto(Xz , Yz :Real);
  172. Var X,Y,X1,X2,Y1,Y2 :Real;
  173.     Ausziehen   :Boolean;
  174.     DrawMode    :Str15;
  175.     Sx,Sy       :Str10;
  176.     Richtung,NewP,
  177.     Start,LastP,Ende      :Vektor;
  178.     G1                    :Gerade;
  179.     L0,List,Lrel,Sigma    :Real;
  180.     Ready                 :Boolean;
  181.     
  182. Begin
  183.   X:=PlotKoord(Xz);
  184.   Y:=PlotKoord(Yz);
  185.   DrehenSpiegeln(X,Y);
  186.   X1:=GrCursorX;X2:=X;
  187.   Y1:=GrCursorY;Y2:=Y;
  188.   Ausziehen:=True;
  189.   If ComInstalled then
  190.   With Setupinfo.PinstInfo do
  191.   begin
  192.     If (GrDraWColor<> 0)  Then DrawMode:=Drawcom Else DrawMode:=MoveCom;
  193.     If Not(Inwindow(X,Y) and InWindow(GrCursorX,GrCursorY)) Then
  194.        Ausziehen:=Clip(X1,Y1,X2,Y2); { Schittpunkte Existent }
  195.     If Ausziehen Then
  196.      Begin
  197.       If Ungleich(GrOldX,X1) or Ungleich(GrOldY,Y1) Then
  198.       begin
  199.          FormReals(X1,Sx);FormReals(Y1,Sy);
  200.          If  NoError Then
  201.          begin {$I-}
  202.            PenDownCount:=0;
  203.            Write(PrOutFile,MoveCom,Sx,SepSym,Sy,EndSym);
  204.            If AufDatei Then  NoError:=IOresult=0;
  205.          end;  {$I+}
  206.          GrOldX:=X1;GrOldY:=Y1;
  207.       end;
  208.       If Ungleich(GrOldX,X2) or Ungleich(GrOldY,Y2) or
  209.          ((GrDrawColor<>0) and (PendownCount=0)) Then
  210.       begin
  211.         If GrDrawColor<>0 then
  212.          begin
  213.            Inc(PendownCount);
  214.            SetPen(GrDrawColor);
  215.          end else PendownCount:=0;
  216.         If (GrDrawColor<>0) and (Grdotted<>full) and Emul_LT then
  217.           begin
  218.             With Richtung Do begin
  219.               X:=X2-GroldX; Y:=Y2-GroldY;
  220.               Vect_Scale(Richtung,1/Laenge(X,Y));{Einheits-Vektor}
  221.             end;
  222.             Start.X:=GroldX;Start.Y:=GroldY;
  223.             Ende.X:=X2;Ende.Y:=Y2;
  224.             L0:=Distanz_VV(Start,Ende);
  225.             LastP:=Start;
  226.             G1.Richtung:=Richtung; G1.Ort:=Start;
  227.             Sigma:=0; Ready:=false;
  228.             Repeat
  229.               CheckPen(DrawMode);
  230.               S_count:=S_count+S_count_rest;
  231.               Sigma:=Sigma+S_count_rest;
  232.               Get_P_G(G1,NewP,Sigma*Linienteilung);
  233.               List:=Distanz_VV(Start,Newp);
  234.               If List-L0>=0 then
  235.                 begin
  236.                   Ready:=true;
  237.                   Newp:=Ende;
  238.                   Lrel:=Distanz_VV(NewP,LastP)/Linienteilung;
  239.                   S_count_rest:=S_count_rest-Lrel;
  240.                   S_count:=S_count-S_count_rest;
  241.                 end
  242.               else CheckCount;
  243.                With NewP do
  244.                begin
  245.                  If Ungleich(GRoldX,X) or Ungleich(GrOldY,Y) then
  246.                  begin
  247.                    FormReals(X,Sx);FormReals(Y,Sy);
  248.                    If  NoError Then
  249.                    begin {$I-}
  250.                       Write(PrOutFile,DrawMode,Sx,SepSym,Sy,EndSym);
  251.                       If AufDatei Then  NoError:=IOresult=0;
  252.                    end;  {$I+}
  253.                    GroldX:=Newp.X;GroldY:=Newp.Y;
  254.                  end;
  255.                end;
  256.                LastP:=NewP;
  257.             Until Ready;
  258.           end { gestrichelt }
  259.         else
  260.           begin
  261.             FormReals(X2,Sx);FormReals(Y2,Sy);
  262.             If  NoError Then
  263.             begin {$I-}
  264.               Write(PrOutFile,DrawMode,Sx,SepSym,Sy,EndSym);
  265.               If AufDatei Then  NoError:=IOresult=0;
  266.             end;  {$I+}
  267.           end;
  268.       end;
  269.       GrOldX:=X2;GrOldY:=Y2;
  270.      End;
  271.    end;
  272.  GrCursorX:=X;GrCursorY:=Y;
  273. End;
  274.  
  275. Const MoveToCircle :Boolean =true;
  276.  
  277. Procedure Circle(CenterX, CenterY ,RX,RY :Real; Alpha,Beta :Integer;
  278.                          CColor: GrColor;Direction :Boolean);
  279. Const Epsilon_mal_8 = 8.0*0.01;
  280.  
  281. Var Phi,Dphi,CPhi       :Integer;
  282.     OldX,OldY,CX,CY     :Real;
  283.     AddBeta             :Integer;
  284.     Xre,Yre,Rmax        :Real;
  285.     Ende                :Boolean;
  286.  
  287. Begin
  288.   If Alpha=Beta Then AddBeta:=0;
  289.   Normalize(Alpha);
  290.   Normalize(Beta);
  291.   If Beta>Alpha Then AddBeta:=0 Else AddBeta:=360;
  292.   RX:=Abs(RX);RY:=Abs(RY);
  293.   IF RX > RY Then Rmax:=RX else Rmax:=RY;
  294.   { Abschätzung:
  295.       r-r*Cos(Dphi/2) < ε
  296.       Cos(X) ≈ 1-1/(X²*2!)    (Taylor-Reihe )
  297.       >>
  298.       DPHI < 2*180/π* √(2*ε/r)
  299.   }
  300.     If Rmax <2 then Dphi:=15
  301.       else Dphi:=Round(Winkelmass(Sqrt(Epsilon_mal_8/Rmax)));
  302.     If Dphi<1 then Dphi:=1;
  303.     Beta:=Beta+AddBeta;
  304.     If Not(Direction) Then
  305.        Begin
  306.          Tausche (Alpha,Beta);
  307.          DPhi:=-Dphi;
  308.          Addbeta:=-Addbeta;
  309.        end;
  310.      SinusCosinus(Alpha,CY,CX);
  311.      CX:=CX*RX;CY:=CY*Ry;
  312.      RotReal(CX,CY);
  313.      OldX:=CX;OldY:=CY;
  314.      If MoveToCircle then
  315.         Pencolor(0)
  316.        else
  317.          PenColor(Ccolor);
  318.      MovetoCircle:=True;
  319.      Moveto(CenterX+CX,CenterY+CY);
  320.      Pencolor(CColor);
  321.      Phi:=alpha;
  322.      Repeat
  323.        Phi:=PHi+DPhi;
  324.        If Direction Then
  325.          begin If Phi >Beta Then Phi:=Beta;end
  326.        else
  327.         begin If Phi <Beta Then Phi:=Beta;end;
  328.        SinusCosinus(Phi,CY,CX);
  329.        CX:=CX*RX;CY:=CY*Ry;
  330.        RotReal(CX,CY);
  331.        If Ungleich(OldX,CX) or Ungleich(OldY,CY) or (PendownCount=0) Then
  332.        Begin
  333.          OldX:=CX;
  334.          OldY:=CY;
  335.          CX:=CX+ CenterX;
  336.          CY:=CY+ CenterY;
  337.          Moveto(CX,CY)
  338.        End;
  339.        If Direction Then
  340.          Ende:=Phi >= Beta
  341.        else
  342.          Ende:=Phi<=Beta;
  343.      Until Ende;
  344.  Pencolor(0);
  345. End;
  346.  
  347. Procedure Eye(CenterX,CenterY,OuterDiaM,InnerDiaM :Real;
  348.               EColor :GrColor);
  349. Var Save     :GrLineType;
  350.     Diminuend :Real;
  351.     InD,SB        :Real;
  352. Begin
  353.    Save:=GrDotted;LineType(full);
  354.    Pencolor(0);
  355.    SB:=0.5*Stiftbreite;
  356.    If PlotModus=Bestueck Then OuterDiaM:=InnerDiaM;
  357.    If PlotModus=Testplot Then
  358.       Diminuend:=Abs(0.499*(OuterDiaM-InnerDiaM))
  359.    Else
  360.       Diminuend:=0.75*Stiftbreite;
  361.    If Diminuend<0.05 Then Diminuend:=0.05;
  362.    OuterDiaM:=0.5*OuterDiaM;
  363.    InnerDiam:=0.5*InnerDiaM;
  364.    Repeat
  365.      Circle(CenterX,CenterY,OuterDiaM,OuterDiaM,0,360,EColor,true);
  366.      MoveToCircle:=false;
  367.      InD:=OuterDiam-SB-0.001; { wirklicher Wert }
  368.      OuterDiaM:=OuterDiaM-Diminuend;
  369.      If OuterDiaM-SB-0.001<InnerDiaM Then OuterDiam:=InnerDiam+SB;
  370.    Until (Plotmodus=Bestueck) or (InD<=InnerDiam);
  371.    MoveToCircle:=True;
  372.    LineType(Save);
  373.   PenColor(0);
  374. End;
  375.  
  376. Procedure ZeichneOval(CenterX,CenterY,OuterDiaM,Ovlen :Real;Ecolor:GrColor);
  377. Var Xm,Ym:Real;
  378.     X1,Y1:Real;
  379. begin
  380.   OuterDiam:=OuterDiam*0.5;
  381.   ym:=OvLen*0.5;
  382.   xm:=0;
  383.   Rotreal(Xm,Ym);
  384.   Circle(CenterX+Xm,CenterY+Ym,OuterDiaM,OuterDiaM,0,180,EColor,true);
  385.   X1:=-OuterDiam;
  386.   Y1:=-Ym;
  387.   RotReal(X1,Y1);
  388.   Pencolor(Ecolor);
  389.   Moveto(CenterX+X1,CenterY+Y1);
  390.   MovetoCircle:=false;
  391.   Circle(CenterX-Xm,CenterY-Ym,OuterDiaM,OuterDiaM,180,360,EColor,true);
  392.   X1:=OuterDiam;
  393.   Y1:=Ym;
  394.   RotReal(X1,Y1);
  395.   Pencolor(Ecolor);
  396.   Moveto(CenterX+X1,CenterY+Y1);
  397. end;
  398.  
  399. Procedure OvalEye(CenterX,CenterY,OuterDiaM,InnerDiaM,OvalLen :Real;
  400.                   EColor :GrColor);
  401. Var Save        :GrLineType;
  402.     Diminuend   :Real;
  403.     InD,SB,Ovl  :Real;
  404. Begin
  405.    Save:=GrDotted;LineType(full);
  406.    Pencolor(0);
  407.    SB:=Stiftbreite;
  408.    If PlotModus=Bestueck Then
  409.     begin
  410.      OuterDiaM:=InnerDiaM;
  411.      OvalLen:=0;
  412.     end;
  413.    If PlotModus=Testplot Then
  414.    begin
  415.       If OvalLen>OuterDiam-InnerDiam then
  416.         Diminuend:=Abs(0.998*OvalLen)
  417.       else
  418.         Diminuend:=Abs(0.998*(OuterDiaM-InnerDiaM));
  419.    end
  420.    Else
  421.       Diminuend:=1.5*Stiftbreite;
  422.    If Diminuend<0.1 Then Diminuend:=0.1;
  423.  
  424.    Repeat
  425.      ZeichneOval(CenterX,CenterY,OuterDiaM,OvalLen,EColor);
  426.      MovetoCircle:=false;
  427.      InD:=OuterDiam-SB-0.002; { wirklicher Wert }
  428.      Ovl:=OvalLen-SB-0.02;
  429.  
  430.      { erst OuterDiam verkleinern bis Ind<=InnerDiam
  431.      dann Ovlen verleinern bis Ovl<=0    }
  432.      If InD<=InnerDiam then
  433.        OvalLen:=OvalLen-Diminuend
  434.      else
  435.        OuterDiaM:=OuterDiaM-Diminuend;
  436.  
  437.      If OuterDiaM-SB-0.002<InnerDiaM Then OuterDiam:=InnerDiam+SB;
  438.      If OvalLen-SB-0.02<0 then OvalLen:=SB;
  439.    Until (Plotmodus=Bestueck) or ((InD<=InnerDiam) and (Ovl<=0));
  440.    MovetoCircle:=true;
  441.    LineType(Save);
  442.   PenColor(0);
  443. End;
  444.  
  445. Procedure SqareEye(CenterX,CenterY,OuterDiaM,InnerDiaM :Real;
  446.                    EColor :GrColor);
  447. Var Ba,Bx1,By1,Bx2,By2,Diminuend :Real;
  448.     Save     :GrLineType;
  449.     InD,SB        :Real;
  450.  
  451. Begin
  452.   Save:=GrDotted;LineType(full);
  453.   SB:=0.5*Stiftbreite;
  454.   If PlotModus=Bestueck Then OuterDiaM:=InnerDiaM;
  455.   If PlotModus=Testplot Then
  456.       Diminuend:=Abs(0.499*(OuterDiaM-InnerDiaM))
  457.    Else
  458.       Diminuend:=0.75*Stiftbreite;
  459.   If Diminuend<0.05 Then Diminuend:=0.05;
  460.   Ba:= OuterDiaM*0.5 ;
  461.   InnerDiaM:=0.5*InnerdiaM;
  462.   Bx1:=Ba;By1:=Ba;Bx2:=-Ba;By2:=Ba;
  463.   Rotreal(Bx1,By1);Rotreal(Bx2,By2);
  464.   Pencolor(0);
  465.   Moveto(CenterX+Bx1,CenterY+By1);
  466.   Pencolor(EColor);
  467.   Repeat
  468.     Moveto(CenterX+Bx2,CenterY+By2);
  469.     Moveto(CenterX-Bx1,CenterY-By1);
  470.     Moveto(CenterX-Bx2,CenterY-By2);
  471.     Moveto(CenterX+Bx1,CenterY+By1);
  472.     InD:=Ba-SB-0.001; { wirklicher Wert }
  473.     Ba:=Ba-Diminuend;
  474.     If Ba-SB-0.001<InnerDiaM Then Ba:=InnerDiam+SB;
  475.     Bx1:=Ba;By1:=Ba;Bx2:=-Ba;By2:=Ba;
  476.     Rotreal(Bx1,By1);Rotreal(Bx2,By2);
  477.   Until (Plotmodus=Bestueck) or (InD<=InnerDiam);
  478.   Pencolor(0);
  479.   LineType(Save);
  480. End;
  481.  
  482. Procedure Octagon(CenterX,CenterY,OuterDiaM,InnerDiaM :Real;
  483.                   EColor :GrColor);
  484. Const Tan22_5=0.5*0.41421356237;
  485.       _Achteck:Array[1..9] of Vektor =
  486.       ((X: 0.5;     Y: Tan22_5) , (X: Tan22_5; Y: 0.5    ),
  487.        (X:-Tan22_5; Y: 0.5    ) , (X:-0.5;     Y: Tan22_5),
  488.        (X:-0.5;     Y:-Tan22_5) , (X:-Tan22_5; Y:-0.5    ),
  489.        (X: Tan22_5; Y:-0.5    ) , (X: 0.5;     Y:-Tan22_5),
  490.        (X: 0.5;Y:   Tan22_5   ));
  491. Var Ba,Bx,By,Diminuend :Real;
  492.     Save               :GrLineType;
  493.     InD,SB             :Real;
  494.     I                  :Integer;
  495.  
  496. Begin
  497.   Save:=GrDotted;LineType(full);
  498.   SB:=Stiftbreite;
  499.   If PlotModus=Bestueck Then OuterDiaM:=InnerDiaM;
  500.   If PlotModus=Testplot Then
  501.       Diminuend:=Abs(0.998*(OuterDiaM-InnerDiaM))
  502.    Else
  503.       Diminuend:=1.5*Stiftbreite;
  504.   If Diminuend<0.1 Then Diminuend:=0.1;
  505.   Ba:= OuterDiaM ;
  506.   Bx:=_Achteck[1].X*Ba;
  507.   By:=_AchtEck[1].Y*Ba;
  508.   Rotreal(Bx,By);
  509.   Pencolor(0);
  510.   Moveto(CenterX+Bx,CenterY+By);
  511.   Pencolor(EColor);
  512.   Repeat
  513.     For I:=2 to 9 do
  514.       begin
  515.         Bx:=_Achteck[I].X*Ba;
  516.         By:=_AchtEck[I].Y*Ba;
  517.         Rotreal(Bx,By);
  518.         Moveto(CenterX+Bx,CenterY+By);
  519.       end;
  520.     InD:=Ba-SB-0.002; { wirklicher Wert }
  521.     Ba:=Ba-Diminuend;
  522.     If Ba-SB-0.002<InnerDiaM Then Ba:=(InnerDiam+SB);
  523.   Until (Plotmodus=Bestueck) or (InD<=InnerDiam);
  524.   Pencolor(0);
  525.   LineType(Save);
  526. End;
  527.  
  528. Procedure Rectangle(X,Y,L,B,Margin :Real;RColor : GrColor);
  529. Var RX,RY,Limit,Offset,Increment  :Real;
  530.     Last,Ende,Once :Boolean;
  531. Begin
  532.   L:=Abs(L);B:=Abs(B);Margin:=Abs(Margin);
  533.   IF B > L Then
  534.     Limit:=L
  535.   Else Limit:=B;
  536.   Limit:=0.5*Limit;
  537.   If Margin+PlotRes < Limit  Then
  538.     begin
  539.       Limit:=Margin;
  540.       Once:=Margin<1.1*Stiftbreite;
  541.       Limit:=Limit-0.6*Stiftbreite;
  542.     end
  543.   else
  544.     begin
  545.       Once:=false;
  546.       Limit:=Limit-0.35*Stiftbreite;
  547.     end;
  548.   Offset:=0;
  549.   If (PlotModus=TestPlot) and Not(Once)  then
  550.      Increment:=5*Stiftbreite
  551.    else
  552.      Increment:=0.75*Stiftbreite;
  553.   If Increment<0.05 Then Increment:=0.05;
  554.   Pencolor(0);
  555.   Moveto(X,Y);
  556.   Pencolor(RColor);
  557.   Last:=false;
  558.   Repeat
  559.     RX:=L-Offset;RY:=Offset;
  560.     Rotreal(RX,RY);
  561.     Moveto(X+RX,Y+RY);
  562.     RX:=L-Offset;RY:=B-Offset;
  563.     Rotreal(RX,RY);
  564.     Moveto(X+RX,Y+RY);
  565.     RX:=Offset;RY:=B-Offset;
  566.     Rotreal(RX,RY);
  567.     Moveto(X+RX,Y+RY);
  568.     RX:=Offset;
  569.     Offset:=Offset+Increment;
  570.     Ende:=Last;
  571.     If (Offset>Limit) and Not(Once) then begin Offset:=Limit;Last:=true;end;
  572.     RY:=Offset;
  573.     Rotreal(RX,RY);
  574.     Moveto(X+RX,Y+RY);
  575.   Until Once or Ende;
  576.   Pencolor(0);
  577. End;
  578.  
  579. Procedure Pfeilspitze(SpitzeX,SpitzeY,Laenge :Real;EColor :GrColor);
  580. Const _Peek :Array[1..4] of Vektor =
  581.       ((X: -2/3;     Y: 0.0    ) , (X: 1/3; Y: 0.13333),
  582.        (X:  1/3;     Y:-0.13333) , (X:-2/3; Y: 0.0    ));
  583.  
  584. Var Bx,By,Diminuend    :Real;
  585.     Save               :GrLineType;
  586.     InD,SB             :Real;
  587.     I                  :Integer;
  588.  
  589. Begin
  590.   Save:=GrDotted;LineType(full);
  591.   SB:=Stiftbreite;
  592.   Bx:=0.666667*Laenge;
  593.   By:=0;
  594.   RotReal(Bx,By);
  595.   SpitzeX:=SpitzeX+Bx;
  596.   SpitzeY:=SpitzeY+By;
  597.   Laenge:=Laenge-Stiftbreite;
  598.   Diminuend:=2.5*Stiftbreite;
  599.   If Diminuend<0.1 Then Diminuend:=0.1;
  600.   Bx:=_peek[1].X*Laenge;
  601.   By:=_peek[1].Y*Laenge;
  602.   Rotreal(Bx,By);
  603.   Pencolor(0);
  604.   Moveto(SpitzeX+Bx,SpitzeY+By);
  605.   Pencolor(EColor);
  606.   Repeat
  607.     For I:=2 to 4 do
  608.       begin
  609.         Bx:=_peek[I].X*Laenge;
  610.         By:=_peek[I].Y*Laenge;
  611.         Rotreal(Bx,By);
  612.         Moveto(SpitzeX+Bx,SpitzeY+By);
  613.       end;
  614.     InD:=0.33*Laenge-SB-0.002; { wirklicher Wert }
  615.     Laenge:=Laenge-Diminuend;
  616.     If 0.33*Laenge-SB-0.002<0 then  Laenge:=SB;
  617.   Until (Plotmodus=TestPlot) or (InD<=0);
  618.   Pencolor(0);
  619.   LineType(Save);
  620. End;
  621.  
  622. Procedure LinePaint(X0,Y0,XE,YE :Real; B :Real;Color :GrColor;
  623.                     Adapt :Boolean);
  624. Type Point = Record
  625.                X,Y :Real;
  626.              end;
  627. Var OldPhi,Alpha :Integer;
  628.     Bhalbe,Dx,Dy,Sb,Laenge,Gesamt,LX,LY,Xp,Yp :Real;
  629.     P1,P2,P3,P4 :Point;
  630.   Procedure GetDXY(Var P :Point);
  631.   begin
  632.     Dx:=P.X*Bhalbe;
  633.     Dy:=P.Y*Bhalbe;
  634.   end;
  635. Begin
  636.   Sb:=Stiftbreite;
  637.   If B<=1.1*Sb Then { 10% der Stiftbreite Toleranz }
  638.   begin
  639.     Pencolor(0);
  640.     Moveto(X0,Y0);
  641.     Pencolor(Color);
  642.     Moveto(XE,YE);
  643.   end
  644.   else
  645.     Begin
  646.       B:=B-Sb;
  647.       If Adapt Then
  648.        begin
  649.          P1.X:=0.0;P1.Y:=1.0;
  650.          P4.X:=0.0;P4.Y:=-1.0;
  651.          P2.X:=-0.75;P2.Y:=0.5;
  652.          P3.X:=-0.75;P3.Y:=-0.5;
  653.        end
  654.       else
  655.        begin
  656.          P1.X:=0.0;P1.Y:=1.0;
  657.          P4.X:=0.0;P4.Y:=-1.0;
  658.          P2.X:=0.0;P2.Y:=0.5;
  659.          P3.X:=0.0;P3.Y:=-0.5;
  660.        end;
  661.       LX:=XE-X0;LY:=YE-Y0;
  662.       Laenge:=Sqrt(Sqr(LX)+Sqr(LY))+B;
  663.       Gesamt:=0.0;
  664.       OldPhi:=GrRotPhi;
  665.       Alpha:=CalcPhi(Realtoint(PlotKoord(XE-X0)),RealtoInt(PlotKoord(YE-Y0)));
  666.       Turnto(Alpha);
  667.       SB:=SB*0.75;
  668.       If Sb<0.05 Then Sb:=0.05;
  669.       Bhalbe:=0.5*B;
  670.       RotReal(P1.X,P1.Y);
  671.       RotReal(P2.X,P2.Y);
  672.       RotReal(P3.X,P3.Y);
  673.       RotReal(P4.X,P4.Y);
  674.       GetDXY(P1);
  675.       Pencolor(0);Moveto(X0+Dx,Y0+Dy);
  676.       Pencolor(Color);
  677.       Repeat
  678.         If Adapt Then
  679.         begin
  680.           GetDXY(P2);Moveto(X0+Dx,Y0+Dy);
  681.           GetDXY(P3);Moveto(X0+Dx,Y0+Dy);
  682.         end;
  683.         GetDXY(P4);Moveto(X0+Dx,Y0+Dy);
  684.         GetDXY(P1);Moveto(XE-Dx,YE-Dy);
  685.         If Adapt Then
  686.         begin
  687.           GetDXY(P2);Moveto(XE-Dx,YE-Dy);
  688.           GetDXY(P3);Moveto(XE-Dx,YE-Dy);
  689.         end;
  690.         GetDXY(P4);Moveto(XE-Dx,YE-Dy);
  691.         GetDXY(P1);Moveto(X0+Dx,Y0+Dy);
  692.         Gesamt:=Gesamt+Laenge;
  693.         If Gesamt>70.0 Then
  694.         Begin
  695.           PenColor(0);
  696.           Moveto(X0+Dx+2.0*PlotRes,Y0+Dy);
  697.           Moveto(X0+Dx,Y0+Dy);
  698.           Pencolor(Color);
  699.           Gesamt:=0.0;
  700.         End;
  701.         B:=B-Sb;
  702.         Bhalbe:=0.5*B;
  703.         If Plotmodus<>Testplot Then
  704.          begin GetDXY(P1);Moveto(X0+Dx,Y0+Dy); end;
  705.       Until (B<0.0) or (Plotmodus=TestPlot);
  706.       Turnto(OldPhi);
  707.     End;
  708.  End;
  709.  
  710. Function TextLaenge(Var T:Bildelement):Integer;
  711. Var Ch              :Char;
  712.     Index           :CHIptr;
  713.     Grafset         :ChFptr;
  714.     Xsum,I,Ci       :Integer;
  715. Begin
  716.   With T Do
  717.     begin
  718.       If (Art and 16)>0 then
  719.         begin Index:=CharIndex2; Grafset:=Grafset2; end
  720.           else
  721.         begin Index:=CharIndex1; Grafset:=Grafset1; end;
  722.       Xsum:=0;
  723.       If (Art and 4) >0 then { Proportional}
  724.         For I:= 1 To Length(WortLaut) Do
  725.          Begin
  726.            Ci:=Ord(Wortlaut[I])-32;
  727.            If Ci<0 then Ci:=0;
  728.            Xsum:=Xsum+(Grafset^[Index^[Ci]].CharX and $F);
  729.           End
  730.        else Xsum:=Length(Wortlaut) shl 3;
  731.       If (Art and 8)>0 then Xsum:=(3*Xsum) shr 2; {*0.75} { Schmalschrift }
  732.       If (Art and 2)>0 then Xsum:=-Xsum; { gespiegelt }
  733.       TextLaenge:=RealtoInt(Hoehe*0.125*Xsum);
  734.     End;
  735. End;
  736. Procedure Wstring(X,Y :Real; YourText :Str80 ; SColor :GrColor;
  737.                   Size :Real; ChTyp :GrChType) ;
  738.  
  739. Var I            :Integer;
  740.     OfsetY,
  741.     SX,SY,
  742.     Breite,Rchar :Real;
  743.     Ch :Char;
  744.     Cursive,Spiegel :boolean;
  745.     Schmal,Prop     :Boolean;
  746.     Index           :CHIptr;
  747.     Grafset         :ChFptr;
  748.     LenSc,Chsc      :Real;
  749.     Xsum            :Integer;
  750.     Charindex,
  751.     Nkanten         :Integer;
  752.     Xofset          :Integer;
  753.     Xprop           :Integer;
  754.     Save : GrLineType;
  755.  
  756.  
  757. Procedure WChar (X,Y:Real;Cindex,Nk :Integer);
  758. Var  CX,CY,I :Integer;
  759.      Cxr,Cyr :Real;
  760.      X0,Y0  :Real;
  761. Begin
  762.   If (Grafset^[Succ (Cindex) ].CharY and $80)>0 then
  763.   { Startposition anfahren }
  764.   begin
  765.     CX:=Xofset;
  766.     If Schmal then CX:=Cx*3 else Cx:=Cx shl 2; {*0.75}
  767.     If Spiegel Then CX:=-CX;
  768.     CXr:=CX*Chsc;
  769.     CYr:=0.0;
  770.     Rotreal(CXr,CYr);
  771.     CXr:=Cxr+X;
  772.     CYr:=Cyr+Y;
  773.     Pencolor(0);Moveto(Cxr,Cyr);
  774.   end;
  775.   X0:=X;Y0:=Y;
  776.   For I:=1 to Nk Do
  777.    With  Grafset^[Cindex+I] Do
  778.     Begin
  779.       CX:=CharX*3; { /4} {*0.75}
  780.       Inc(CX,Xofset);
  781.       CY:=CharY and $7F;
  782.       If Cursive Then Inc(CX,CY);          {+ Y/4}
  783.       If Schmal then CX:=Cx*3 else Cx:=Cx shl 2; {*0.75}
  784.       CY:=CY shl 4;
  785.       If Spiegel Then CX:=-CX;
  786.       CXr:=CX*Chsc;
  787.       CYr:=CY*Chsc;
  788.       Rotreal(CXr,CYr);
  789.       CXr:=Cxr+X;
  790.       CYr:=Cyr+Y;
  791.       If (CharY and $80)=0 Then
  792.         begin
  793.           Pencolor(0);
  794.           Moveto(CXr,CYr);
  795.         end
  796.       Else
  797.           Linepaint(X0,Y0,Cxr,Cyr,Breite,SColor,true);
  798.        X0:=Cxr;Y0:=Cyr;
  799.     end;
  800. End;
  801.  
  802. Begin
  803.   RChar:=25.0*Size;
  804.   Save:=GrDotted;LineType(full);
  805.   Cursive:=(Chtyp and 1)>0;
  806.   Spiegel:=(Chtyp and 2)>0;
  807.   Prop:=(Chtyp and 4)>0;
  808.   Schmal:=(Chtyp and 8)>0;
  809.   If (Chtyp and 16)>0 then
  810.     begin Index:=CharIndex2; Grafset:=Grafset2; end
  811.         else
  812.     begin Index:=CharIndex1; Grafset:=Grafset1; end;
  813.   If Schmal then LenSc:=Size*0.09375 else LenSc:=Size*0.125;
  814.   CHsc:=Size*4.61368E-4;{*15/(16*127)*0.0625};
  815.   OfsetY:=Size*0.0625+0.1;
  816.   If PlotModus=Testplot then
  817.      Breite:=0
  818.   else
  819.    begin
  820.      Breite:=Size*SchriftDicke;
  821.      If Breite<StiftBreite then Breite:=0;
  822.      If Breite>0.2*Size then Breite:=0.2*Size;
  823.    end;
  824.   Xsum:=0;
  825.   Xofset:=0;
  826.   For I:= 1 To Length(YourText) Do
  827.     Begin
  828.       SX:=Xsum*LenSc;
  829.       If Spiegel then SX:=-SX;
  830.       SY:=OfsetY;
  831.       Rotreal(SX,SY);
  832.       SX:=SX+X;SY:=Sy+Y;
  833.       CharIndex:=Ord(YourText[I])-32;
  834.       If CharIndex<0 then CharIndex:=0;
  835.       CharIndex:=Index^[CharIndex];
  836.       With Grafset^[CharIndex] Do
  837.       begin
  838.         Xprop:=CharX and $F;
  839.         Nkanten:=Pred( CharY );
  840.       end;
  841.       If Prop then
  842.        begin
  843.          Xofset:=Xprop shl 3;
  844.          Inc(Xsum,xprop);
  845.        end
  846.        else
  847.          begin
  848.            Xofset:=(32-Xprop*3) shl 3;
  849.            Inc(Xsum,8);
  850.          end;
  851.       WChar(SX,SY,CharIndex,Nkanten);
  852.     End;
  853.   Pencolor(0);
  854.   LineType(Save);
  855. End;
  856.  
  857. Procedure Pfeil(X,Y,Laenge,Groesse:Real; MText :Str80;
  858.                         Color :GrColor);
  859. Var TextLaenge,
  860.     AXtext,AYText,
  861.     InitX,InitY,EndX,EndY,
  862.     L0x,L0y,PL,PH,Px,Py,Px1,Py1 :Real;
  863.     Aussen       :Boolean;
  864.     Hoehe :Real;
  865. Procedure Stretch(Var X:Real);
  866. Begin
  867.   X:=Groesse*X;
  868. End;
  869. Begin
  870.   With SetupInfo.Voreinstellung Do
  871.      Hoehe:=Einheit*Masshoehe;
  872.   TextLaenge:=Hoehe*Length(MText);
  873.   Laenge:=Abs(Laenge);
  874.   With SetupInfo.Voreinstellung do
  875.   begin
  876.     AYText:=Einheit;PL:=Einheit*Masshoehe;PH:=Pl*0.3;
  877.     L0x:=Laenge;L0Y:=0;
  878.     InitY:=0;EndY:=L0y;
  879.     If TextLaenge<Laenge-(PL*2.0) Then
  880.       Begin
  881.         AXtext:=0.5*(Laenge-TextLaenge);
  882.         InitX:=0.0;EndX:=L0x;
  883.         Aussen:=false;
  884.       End
  885.      Else
  886.       Begin
  887.         AXtext:=Laenge+PL+Einheit;
  888.         InitX:=-PL*2.0;
  889.         EndX:=Axtext+TextLaenge+Einheit*4.0;
  890.         Aussen:=true;
  891.       End;
  892.   end;
  893.   Stretch(AxText);Stretch(AyText);
  894.   Stretch(InitX);Stretch(EndX);
  895.   Stretch(L0X);Stretch(PL);Stretch(PH);
  896.   Stretch(Hoehe);
  897.   Rotreal(InitX,InitY);
  898.   Pencolor(0);Moveto(X+InitX,Y+InitY);
  899.   Rotreal(EndX,EndY);Rotreal(L0x,L0y);
  900.   L0x:=L0x+X;L0y:=L0y+Y;
  901.   Pencolor(Color);Moveto(X+EndX,Y+EndY);
  902.   If Aussen Then PL:=-PL;
  903.   Px:=PL;Py:=PH;Rotreal(Px,Py);
  904.   Px1:=X+Px;Py1:=Y+Py;
  905.   Pencolor(0);Moveto(Px1,Py1);
  906.   Pencolor(Color);Moveto(X,Y);
  907.   Px:=PL;Py:=-PH;Rotreal(Px,Py);
  908.   Moveto(X+Px,Y+Py);
  909.   Moveto(Px1,Py1);
  910.   Px:=-PL;Py:=PH;Rotreal(Px,Py);
  911.   Px1:=L0X+Px;PY1:=L0Y+Py;
  912.   Pencolor(0);Moveto(Px1,Py1);
  913.   Pencolor(Color);Moveto(L0X,L0Y);
  914.   Px:=-PL;Py:=-PH;Rotreal(Px,Py);
  915.   Moveto(L0X+Px,L0Y+Py);
  916.   Moveto(Px1,Py1);
  917.   Rotreal(AxText,AyText);
  918.   Pencolor(0);
  919.   Wstring(X+AxText,Y+AyText,Mtext,Color,Hoehe,0);
  920. End;
  921.  
  922. Procedure InitBackSc;
  923. begin
  924.   With SetupInfo.Voreinstellung Do
  925.     BackScale:=PlotRes/(PlotScale*Einheit);
  926. end;
  927.  
  928. Procedure InitLayersetofPen;
  929. Var Pen,Ebene :Integer;
  930. begin
  931.   For Pen:=1 to 9 Do
  932.   begin
  933.    LayersetofPen[Pen]:=[];
  934.    For Ebene:=0 to Maxlayer do
  935.     If PenLookUp[EbenenIndex(Ebene)]=Pen Then
  936.        LayerSetofPen[Pen]:=LayersetofPen[Pen]+[Ebene];
  937.    LayerSetofPen[Pen]:=LayersetofPen[Pen] * Plotlayers;
  938.   end;
  939. end;
  940.  
  941. Procedure PlotReset;
  942. Begin
  943.   GrCursorX:=0;
  944.   GrCursorY:=0;
  945.   GrOldX:=0;
  946.   GrOldY:=0;
  947.   PlOldPen:=0;
  948.   GrDotted:=full;
  949.   PendownCount:=0;
  950.   LastLineType:=Full;
  951.   With SetupInfo.PinstInfo do
  952.     If  NoError Then
  953.      begin {$I-}
  954.        If ResetCom<>'' Then Write(PrOutFile,Resetcom,EndSym);
  955.        If AufDatei Then  NoError:=IOresult=0;
  956.       end;  {$I+}
  957.   PenColor(0);Moveto(0,0);
  958. End;
  959.  
  960. Function Istmass(Origin: Integer):Real;
  961.  Begin
  962.   With SetupInfo.Voreinstellung Do
  963.      Istmass:=Origin*Einheit;
  964.  End;
  965.  
  966. Function Rastermass(Mass : Real):Integer;
  967. Begin
  968.   With SetupInfo.Voreinstellung Do
  969.     Rastermass:=RealtoInt(Mass/Einheit);
  970. End;
  971.  
  972.  
  973.